Het basis Excel sheet is simpel bestaat uit een aantal sheets:
#If False Then
Dim Range, Accounts, BudgetLine, Category, Color, RowContent
#End If
Option Explicit
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
Sub OptimizeCode_Begin()
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
End Sub
Sub OptimizeCode_End()
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
End Sub
'
' Main sub to start
'
Sub Categorize()
Dim importsheetRow As Long
Dim RuleRow As Long
Dim RuleColumn As Long
Dim RuleColumnLetter As String
Dim RuleImportLookupColumn As String
Dim RuleComparisonRule As String
Dim IsEmptyCell As Boolean
Dim RuleComparisonValue As Range
Dim ImportValue As Range
Dim RuleIsTrue As Boolean
Dim ImportCategoryColumn As String
Dim CurrentCategory As String
Dim FutureCategory As String
Dim FutureCategoryColor As Long
Dim ShouldWriteCategory As Boolean
Dim AmountRuleMatches As Integer
Call OptimizeCode_Begin
For importsheetRow = 2 To ThisWorkbook.Sheets("Import").Range("A" & Rows.Count).End(xlUp).row
ImportCategoryColumn = ThisWorkbook.Sheets("Rules").Range("A1").Text
CurrentCategory = ThisWorkbook.Sheets("Import").Range(ImportCategoryColumn + CStr(importsheetRow)).Text
If True Or (CurrentCategory = "") Then
For RuleRow = 4 To ThisWorkbook.Sheets("Rules").Range("A" & Rows.Count).End(xlUp).row
RuleIsTrue = True
AmountRuleMatches = 0
For RuleColumn = 3 To ThisWorkbook.Sheets("Rules").Cells(1, Columns.Count).End(xlToLeft).Column
RuleColumnLetter = Col_Letter(RuleColumn)
RuleImportLookupColumn = ThisWorkbook.Sheets("Rules").Range(RuleColumnLetter + "1").Text
RuleComparisonRule = ThisWorkbook.Sheets("Rules").Range(RuleColumnLetter + "3").Text
If Not IsEmpty(ThisWorkbook.Sheets("Rules").Range(RuleColumnLetter + CStr(RuleRow))) Then
Set RuleComparisonValue = ThisWorkbook.Sheets("Rules").Range(RuleColumnLetter + CStr(RuleRow))
Set ImportValue = ThisWorkbook.Sheets("Import").Range(RuleImportLookupColumn + CStr(importsheetRow))
If (RuleComparisonRule = "Smaller") Then
If Not (RuleComparisonValue.Value < ImportValue.Value) Then
RuleIsTrue = False
Exit For
Else
AmountRuleMatches = AmountRuleMatches + 1
End If
End If
If (RuleComparisonRule = "Larger") Then
If Not (RuleComparisonValue.Value > ImportValue.Value) Then
RuleIsTrue = False
Exit For
Else
AmountRuleMatches = AmountRuleMatches + 1
End If
End If
If (RuleComparisonRule = "Equal") Then
If (IsNumeric(RuleImportLookupColumn)) Then
If Not (RuleComparisonValue.Value = ImportValue.Value) Then
RuleIsTrue = False
Exit For
Else
AmountRuleMatches = AmountRuleMatches + 1
End If
Else
If Not (RuleComparisonValue.Text = ImportValue.Text) Then
RuleIsTrue = False
Exit For
Else
AmountRuleMatches = AmountRuleMatches + 1
End If
End If
End If
If (RuleComparisonRule = "Contains") Then
If (ImportValue.Text = "") Or (Not (ImportValue.Text Like "*" + RuleComparisonValue.Text + "*")) Then
RuleIsTrue = False
Exit For
Else
AmountRuleMatches = AmountRuleMatches + 1
End If
End If
If (RuleComparisonRule = "StartsWith") Then
If (ImportValue.Text = "") Or (Not Left(ImportValue.Text, Len(RuleComparisonValue)) = RuleComparisonValue) Then
RuleIsTrue = False
Exit For
Else
AmountRuleMatches = AmountRuleMatches + 1
End If
End If
If (RuleComparisonRule = "Empty") Then
If ImportValue.Text <> "" Then
RuleIsTrue = False
Exit For
Else
AmountRuleMatches = AmountRuleMatches + 1
End If
End If
End If
Next RuleColumn
If RuleIsTrue = True And AmountRuleMatches > 0 Then
FutureCategory = ThisWorkbook.Sheets("Rules").Range("A" + CStr(RuleRow)).Text
If CurrentCategory = "" Then
ThisWorkbook.Sheets("Import").Range(ImportCategoryColumn + CStr(importsheetRow)).Value = FutureCategory
ThisWorkbook.Sheets("Import").Range(ImportCategoryColumn + CStr(importsheetRow)).Interior.ColorIndex = 4
ElseIf CurrentCategory <> FutureCategory Then
ThisWorkbook.Sheets("Import").Range(ImportCategoryColumn + CStr(importsheetRow)).Interior.ColorIndex = 3
ThisWorkbook.Sheets("Import").Range("AB" + CStr(importsheetRow)).Value = FutureCategory
ElseIf CurrentCategory = FutureCategory Then
ThisWorkbook.Sheets("Import").Range(ImportCategoryColumn + CStr(importsheetRow)).Interior.ColorIndex = 50
Else
ThisWorkbook.Sheets("Import").Range(ImportCategoryColumn + CStr(importsheetRow)).Interior.ColorIndex = 9
End If
Exit For
End If
Next RuleRow
End If
Next importsheetRow
Call OptimizeCode_End
MsgBox "Klaar!"
End Sub